perm filename DISKO.FOR[ZZZ,LCS] blob
sn#439875 filedate 1979-05-08 generic text, type T, neo UTF8
C****** DISKO, CLOSIT, BLOCK DATA (DSK CHANNELS), PACKER, PACKX ******
SUBROUTINE DISKO(N,RNAM,J)
C N=DEVICE NUMBER, RNAM=FILE NAME, J=0=OUTPUT, =-1=INPUT
C J=1=UNFORMATTED IN, =2=UNFORMATTED OUT
C J=3=FORMATTED IN, =4=FORMATTED OUT
GO TO (1,2,3,4)J
CC1 CALL IFILE(N,RNAM)
1 CALL OPEN(N,RNAM,0,'RDO',,,'UNF')
RETURN
CC2 CALL OFILE(N,RNAM)
2 CALL OPEN(N,RNAM,0,'NEW',,,'UNF')
RETURN
CC3 CALL IFILE(N,RNAM)
3 CALL OPEN(N,RNAM,0,'RDO',,,'FOR')
RETURN
CC4 CALL OFILE(N,RNAM)
4 CALL OPEN(N,RNAM,0,'NEW',,,'FOR')
RETURN
END
SUBROUTINE CLOSIT(IDEV)
CALL CLOSE(IDEV)
CC ENDFILE IDEV
END
BLOCK DATA
COMMON /DEVS/ID1,ID21,JTYPE,ID23,ID20
DATA JTYPE/5/,ID23/23/,ID20/20/,ID1/1/,ID21/21/
END
SUBROUTINE PACKER(RNAM,INP)
DIMENSION INP(1),KNM(5)
DATA IBLA/' '/,ISEMI/';'/,IEQU/'='/
CCC DATA IBLA/' '/,ISEMI/';'/,IARO/"575004020100/,IEQU/'='/
C ABOVE FOR PDP10 ONLY*********
C N=WDCNT
C****** THE BIG NUMBER=LEFT ARROW
DO 1 J=1,80
N=INP(J)
IF(N.EQ.IEQU)GO TO 2
CCC IF(N.EQ.IARO.OR.N.EQ.IEQU)GO TO 2
1 IF(N.EQ.IBLA.OR.N.EQ.ISEMI)GO TO 2
2 II=J
J=J-1
N=J
IF(J.GT.4)N=4
4 DO 10 K=1,4
IF(K.GT.N)GO TO 11
KNM(K)=INP(K)
GO TO 10
11 KNM(K)=IBLA
10 CONTINUE
CALL PACKX(RNAM,KNM)
RETURN
END
CC SUBROUTINE PACKX(NAM,KNM)
CC DIMENSION KNM(5)
CC DATA KK/128/,LL/"377777777777/,JJ/"2000000000/
CC 1 , MM/"774000000000/,IBLA/' '/
CC KNM(5)=IBLA
C BECAUSE 5 CHARS IN PDP10 WORD.
CC NAM=0
CC DO 12 K=5,1,-1
CC NAM=NAM .OR. (KNM(K) .AND. MM)
CC IF (K.EQ.1)RETURN
CC17 IF (NAM.GE.0)GO TO 13
CC NAM = (( NAM .AND. LL)/KK) .OR. JJ
CC GO TO 12
CC13 NAM = NAM / KK
CC12 CONTINUE
CC RETURN
CC END
SUBROUTINE PACKX(A4RET,KPAC)
DIMENSION KPAC(1)
LOGICAL*1 A4RET(4)
DO 1 K=1,4
1 A4RET(K)=KPAC(K)
C PACKS 4 CHARS. INTO SINGLE, REAL WORD (4 BYTES)
RETURN
END